home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / choices.lisp < prev    next >
Text File  |  1991-07-15  |  12KB  |  300 lines
  1. ;; -*- MODE:LISP; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. ;;; CHOICES:
  22.  
  23.  
  24. (in-package "CLIO-OPEN")
  25.  
  26. (EXPORT '(
  27.       choices
  28.       choice-default
  29.       choice-font
  30.       choice-policy
  31.       choice-selection
  32.       make-choices
  33.       ))
  34.  
  35.  
  36. ;;;  ============================================================================
  37. ;;;                  T h e   C H O I C E S   C o n t a c t
  38. ;;;  ============================================================================
  39.  
  40. (defcontact choices (table)
  41.   
  42.   ((font     :type         fontable
  43.          :accessor    choice-font
  44.         :initarg    :font
  45.          :initform     nil)
  46.  
  47.    (selection   :type           (or null contact)
  48.                 :accessor       choice-selection
  49.                 :initform       nil)
  50.  
  51.    (default    :type        (or null contact symbol)
  52.                 :accessor       choice-default
  53.         :initform    nil
  54.         :initarg    :default-selection)
  55.  
  56.    (policy    :type        (member :always-one :one-or-none)
  57.         :accessor    choice-policy
  58.         :initarg    :choice-policy
  59.         :initform    :one-or-none))
  60.   
  61.   (:resources
  62.     font
  63.     (default-selection :type symbol :initform nil)
  64.     (choice-policy     :type (member :always-one :one-or-none)
  65.                :initform :one-or-none) 
  66.     (horizontal-space  :initform -1)
  67.     (vertical-space    :initform -1))
  68.  
  69.   (:documentation
  70.     "Allows a user to choose at most one choice item."))
  71.  
  72.  
  73. (DEFUN make-choices (&rest initargs &key &allow-other-keys)
  74.   (DECLARE (VALUES choices))
  75.   (APPLY #'make-contact 'choices initargs))
  76.  
  77. ;;  Add our callbacks to each child as it is added, before anybody else gets in ahead of us...
  78. (DEFMETHOD add-child :after ((choices choices) this-child &key)
  79.   (flet
  80.     (
  81.      ;;; ===============================================================================
  82.      ;;;
  83.      ;;;                   Our :change-allowed-p callback function...
  84.      ;;;    Applied by a choice-item child when the user tries to change its state
  85.      ;;;        Tells the child whether or not the change may occur
  86.      ;;;
  87.      ;;;
  88.      (choices-change-allowed-p (to-selected-p choices)
  89.        (ECASE (choice-policy choices)
  90.      (:always-one (or to-selected-p
  91.               ;; Following allows deselection of old selection
  92.               ;; when transitioning to new selection. [See
  93.               ;; (SETF choice-selection) for details.]
  94.               (boundp '*within-setf-choice-selection*))) 
  95.      (:one-or-none t)))
  96.  
  97.      ;;; ===============================================================================
  98.      ;;;
  99.      ;;;       Our :changing and :canceling-change callback functions...
  100.      ;;;
  101.      (choices-changing (to-selected-p choices self)
  102.        (LET((selection (choice-selection choices))
  103.         (default (choice-default choices)))
  104.  
  105.      (WHEN (and to-selected-p selection (not (eq selection self)))
  106.        ;; When transitioning to selected state we must turn off
  107.        ;; the highlighting of the current choice selection, if any.
  108.        (SETF (choice-item-highlight-selected-p selection) nil))
  109.  
  110.      (WHEN (AND default (NOT (EQ self default)))
  111.        ;; If there is a current choice default then we *may* have
  112.        ;; to temporarily inhibit display of the default ring.
  113.        (UNLESS (and selection to-selected-p)
  114.          ;; If there is a current selection already and we are
  115.          ;; transitioning *to* selected state then the current
  116.          ;; selection must be a toggle button (or some other
  117.          ;; button whose state is sticky.) In that case the
  118.          ;; default ring will already have been inhibited by
  119.          ;; that button's selection. Otherwise we inhibit the
  120.          ;; the default ring now.
  121.          (SETF (choice-item-highlight-default-p default) (not to-selected-p))))))
  122.  
  123.      (choices-canceling-change (to-selected-p choices self)
  124.        (LET((selection (choice-selection choices))
  125.         (default (choice-default choices)))
  126.  
  127.      (WHEN (and to-selected-p selection)
  128.        ;; If canceling change to selected state we must restore
  129.        ;; highlight of old selection (if any)
  130.        (SETF (choice-item-highlight-selected-p selection) t))
  131.  
  132.      (WHEN (AND default (NOT (EQ default self)))
  133.        ;; If we are canceling a transition to "selected" then we
  134.        ;; must restore the inhibited default ring display.
  135.        ;; If, on the other hand, we are canceling a transition
  136.        ;; back to "unselected" then we must once again inhibit
  137.        ;; default ring display.
  138.        (UNLESS (and selection to-selected-p)
  139.          ;; As in choices-changing, if there is a current selection
  140.          ;; already inhibiting default ring display then we need not
  141.          ;; restore display here.
  142.          (SETF (choice-item-highlight-default-p default) to-selected-p)))))
  143.  
  144.  
  145.      ;;; ================================================================================
  146.      ;;;    This :off callback deselects currently selected child and
  147.      ;;;        resets the choice selection to NIL. We assume choice policy
  148.      ;;;        enforcement is done elsewhere and so allow deselection even
  149.      ;;         if :always-one.
  150.      ;;;
  151.      (choices-off (choices self)
  152.        (DECLARE (IGNORE self))
  153.        ;;  +++ Gross hack until I find out what's really wrong.
  154.        (unless (boundp '*within-setf-choice-selection*)
  155.      (SETF (choice-selection choices) nil)))
  156.  
  157.      ;; ================================================================================
  158.      ;;    This :on callback deselects currently selected child (if any) and
  159.      ;;        resets the choice selection to point to the specified child. 
  160.      ;;
  161.      (choices-on (choices self)
  162.     (change-choices-selection choices self)))
  163.  
  164.     (let((font (choice-font choices)))
  165.       (WHEN font (SETF (choice-item-font this-child) font)))
  166.  
  167.     ;;  Make this child the default if the child's name is currently the default...
  168.     (with-slots (default) choices
  169.       (when (and (symbolp default) (eq default (contact-name this-child)))
  170.     (setf default nil)
  171.     (setf (choice-default choices) this-child)))
  172.  
  173.     (add-callback this-child :change-allowed-p #'choices-change-allowed-p choices)
  174.     (add-callback this-child :changing #'choices-changing choices this-child)
  175.     (add-callback this-child :canceling-change #'choices-canceling-change choices this-child)
  176.     (add-callback this-child :on #'choices-on choices this-child)
  177.     (add-callback this-child :off #'choices-off choices this-child)
  178.  
  179.     ;;  This callback provides a hook used by the menu code.
  180.     (apply-callback choices :new-choice-item this-child)))
  181.  
  182.  
  183. (defmethod change-layout :after ((choices choices) &optional newly-managed)
  184.   (declare (ignore newly-managed))
  185.   (with-slots (policy selection children) choices
  186.     (unless (realized-p choices)
  187.       (when (and (eq policy :always-one) (not selection) children)
  188.     (setf (choice-selection choices) (first children))))))
  189.  
  190.  
  191. ;;; ===============================================================================
  192. ;;;
  193. ;;;              Method to set the default choice item...
  194. ;;;
  195.  
  196. (DEFMETHOD (SETF choice-default) (new-default-choice-item (choices choices))
  197.   (with-slots (default children) choices
  198.     (UNLESS (EQ new-default-choice-item default)
  199.       (ASSERT (MEMBER new-default-choice-item children)
  200.           NIL
  201.     "New default choice-item ~a is not a child of ~a."
  202.     new-default-choice-item choices)
  203.       (when default (setf (choice-item-highlight-default-p default) NIL))
  204.       (setf default new-default-choice-item)
  205.       (setf (choice-item-highlight-default-p default) T)))
  206.   new-default-choice-item)
  207.  
  208.  
  209.  
  210.  
  211. ;;; ===============================================================================
  212. ;;;
  213. ;;;            Method to set the selected choice-items...
  214. ;;;
  215.  
  216. ;;  Assume ALL programmatic changes to the set of selected children come through here so all
  217. ;;  enforcement of the choice-policy is done here...
  218.  
  219. (defmethod change-choices-selection ((choices choices) child-to-be-selected)
  220.   (declare (type (or null contact) child-to-be-selected))
  221.   (declare (values child-to-be-selected))
  222.   
  223.   (with-slots (children selection) (the choices choices)
  224.     (unless (eq selection child-to-be-selected)   
  225.       
  226.       ;;  Don't check for compliance while we're in the middle of a change...
  227.       (unless (boundp '*within-setf-choice-selection*)
  228.     (assert
  229.       (or child-to-be-selected (eq (choice-policy choices) :one-or-none)) nil
  230.       "Violating :always-one choice policy of choices contact ~a." choices))
  231.       
  232.       (let ((*within-setf-choice-selection* t))
  233.     (declare (special *within-setf-choice-selection*))
  234.     
  235.     ;;  Make sure the caller's selection is indeed a child of ours...
  236.     (assert
  237.       (or (null child-to-be-selected) (member child-to-be-selected children)) nil
  238.       "Selection ~a is not a child of ~a." child-to-be-selected choices)            
  239.     
  240.     ;; We must do things in just the right order here in case choice
  241.     ;; policy is :always-one, in which case turning off the old
  242.     ;; choice-item-selected-p is a bit tricky. In particular, the
  243.     ;; :change-allowed callback will fail unless we first update the
  244.     ;; current choices selection with the new value so it knows the
  245.     ;; choice policy will not be violated. 
  246.     
  247.     (let ((old-selection selection)) 
  248.       (when old-selection (setf (choice-item-selected-p old-selection) nil))
  249.       (setf selection child-to-be-selected)))))
  250.       
  251.   child-to-be-selected)
  252.  
  253. (defmethod (setf choice-selection) (child-to-be-selected (choices choices))
  254.   (change-choices-selection choices child-to-be-selected)
  255.   (when child-to-be-selected
  256.     (setf (choice-item-selected-p child-to-be-selected) t))
  257.   child-to-be-selected)
  258.  
  259.  
  260.  
  261. ;;; ===============================================================================
  262. ;;;
  263. ;;;                   Method to force the font of all children...
  264. ;;;
  265.  
  266. (DEFMETHOD (SETF choice-font) (new-value (choices choices))
  267.   
  268.   (with-slots (children font) choices
  269.     (IF new-value
  270.     (PROGN
  271.       (SETF font (find-font choices new-value))
  272.       (DOLIST (child children)
  273.         (SETF (choice-item-font child) new-value)))
  274.     ;; Setting font to NIL allows the children to have distinct fonts
  275.     ;; so we skip resetting choice-item font slots on children.
  276.     (SETF font NIL))
  277.   new-value))  ;; grh 7/27
  278.  
  279.  
  280. ;;; ===============================================================================
  281. ;;;
  282. ;;;                   Method to set the choice-policy...
  283. ;;;
  284.  
  285. (DEFMETHOD (SETF choice-policy) (new-policy (choices choices))
  286.   (with-slots (policy children selection default) choices
  287.     (ECASE new-policy
  288.       (:always-one                ; Make sure one child is selected...
  289.        (when (null selection)
  290.      (if default 
  291.          (setf (choice-selection choices)  default)
  292.          (if children
  293.          (setf (choice-selection choices) (first children))
  294.          (assert nil nil "~s choices does not have a default or children")))))
  295.       (:one-or-none                ; Nothing more to do...
  296.        nil))
  297.     (SETF policy new-policy)
  298.     new-policy))
  299.  
  300.